{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Text.ZParse.DeltaParser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Two continuation, two input-stream parser combinators!
-- 
--------------------------------------------------------------------------------

module Text.ZParse.DeltaParser
  (

    module Text.ZParse.Combinators      -- re-export
  , Parser

  , Result(..)
  , ParseError

  , runParser

  , runParserEither

  , apply
  , failure
  , throwError
  , (<?>)
  , lookahead
  , peek
  , eof

  , token
  , tokenZ

  , insert
  , insertZ

  , delete
  , deleteZ

  , transpose
  , transposeZ

{-
  , symbol
  , satisfy
  , prefix
  , prefix1
  , suffix
  , suffix1
-}
  ) where


import Text.ZParse.Combinators


import Control.Applicative
import Control.Monad



inputEOF :: [inp] -> [inp] -> Bool
inputEOF ls rs = null ls && null rs


data Result tok ans = Fail String | Okay ![tok] ![tok] ans 


type SK tok a ans = a -> FK tok ans -> [tok] -> [tok] -> Result tok ans
type FK tok ans   = Result tok ans


newtype Parser tok a = Parser { 
      getParser :: forall ans. 
                   SK tok a ans -> FK tok ans -> [tok] -> [tok] -> Result tok ans }


type ParseError   = String




runParser :: Parser tok a -> [tok] -> [tok] -> Result tok a
runParser p tls trs = getParser p skZero fkZero tls trs
  where
    skZero = \ans _ ls rs -> Okay ls rs ans
    fkZero = Fail ""




runParserEither :: Parser tok a -> [tok] -> [tok] -> Either ParseError a
runParserEither p ls rs = post $ runParser p ls rs
  where    
    post (Okay _ _ a)  = Right a
    post (Fail err)    = Left err




-- @return@ of Monad, @pure@ of Applicative
--
yield  :: a -> Parser tok a
yield a = Parser $ \sk fk ss -> sk a fk ss


-- mplus of MonadPlus, (<|>) of Applicative.
--
alt :: Parser tok a -> Parser tok a -> Parser tok a
alt p1 p2 = Parser $ \sk fk ls rs -> 
              getParser p1 sk (getParser p2 sk fk ls rs) ls rs


infixl 5 `apply`

apply :: Parser tok a -> (a -> b) -> Parser tok b
apply = flip fmap


failure :: Parser tok a
failure = Parser $ \_ fk _ _ -> fk


-- eager-many / zero-or-more (many of Applicative)
--
eagerMany :: Parser tok a -> Parser tok [a]
eagerMany p = (p >>= \z -> eagerMany p `apply` \zs -> (z:zs)) `alt` return [] 


-- eager-some / one-or-more (some of Applicative)
--
eagerSome :: Parser tok a -> Parser tok [a]
eagerSome p = p >>= \z -> eagerMany p `apply` \zs -> (z:zs)


instance Functor (Parser tok) where
  fmap f mf = Parser $ \sk -> getParser mf $ \a -> (sk . f) a
     


instance Applicative (Parser tok) where
  pure = yield
  (<*>) = ap

instance Alternative (Parser tok) where
  empty = failure
  (<|>) = alt
  many  = eagerMany
  some  = eagerSome

 
instance Monad (Parser tok) where
  return  = yield
  m >>= k = Parser $ \sk -> getParser m $ \a -> getParser (k a) sk


instance MonadPlus (Parser tok) where
  mzero = failure
  mplus = alt



--------------------------------------------------------------------------------
-- Combinators


throwError :: String -> Parser tok a
throwError err_msg = Parser $ \_ _ _ _ -> Fail err_msg


infixr 0 <?>

(<?>) :: Parser tok a -> String -> Parser tok a
p <?> err_msg = Parser $ \sk fk ls rs -> getParser p sk (swapMsg fk) ls rs
  where
    swapMsg (Fail _) = Fail err_msg
    swapMsg okay     = okay


-- | This one is from Chris Okasaki\'s \"Even Higher-Order 
-- Functions for Parsing\".
--
lookahead :: Parser tok a -> (a -> Parser tok b) -> Parser tok b 
lookahead p mf  = Parser $ \sk fk -> 
    getParser p (\a fk2 -> getParser (mf a) sk fk2) fk



-- | Peek tries the supplied parse, but does not consume input 
-- \*\* even when the parse succeeds \*\*.
--
peek :: Parser tok a -> Parser tok a
peek p = Parser $ \sk fk ls rs -> 
    getParser p (\a fk2 _ _ -> sk a fk2 ls rs) fk ls rs


-- | Both streams must be finished.
--
eof :: Parser tok ()
eof = Parser go
  where
    go sk fk ls rs | inputEOF ls rs = sk () fk ls rs
    go _  fk _  _                   = fk



token :: Eq tok => tok -> Parser tok tok
token tok = Parser go
  where
    go sk fk (l:ls) (r:rs) | l == tok && r == tok = sk l fk ls rs
    go _  fk _      _                             = fk


tokenZ :: Eq tok => Parser tok tok
tokenZ = Parser go
  where
   go sk fk (l:ls) (r:rs) | l == r = sk l fk ls rs
   go _  fk _      _               = fk 

-- | Matches a token in the right stream does not touch the
-- left stream.
--
insert :: Eq tok => tok -> Parser tok tok
insert tok = Parser go
  where
    go sk fk ls (r:rs) | r == tok = sk r fk ls rs
    go _  fk _  _                 = fk


insertZ :: Parser tok tok
insertZ = Parser go
  where
    go sk fk ls (r:rs) = sk r fk ls rs
    go _  fk _  _      = fk


delete :: Eq tok => tok -> Parser tok tok
delete tok = Parser go
  where
    go sk fk (l:ls) rs | l == tok = sk l fk ls rs
    go _  fk _      _             = fk

deleteZ :: Parser tok tok
deleteZ = Parser go
  where
    go sk fk (l:ls) rs = sk l fk ls rs
    go _  fk _      _  = fk


transpose :: Eq tok => tok -> tok -> Parser tok (tok, tok)
transpose tokl tokr = Parser go
  where
    go sk fk (l:ls) (r:rs) | l == tokl && r == tokr = sk (l,r) fk ls rs
    go _  fk _      _                               = fk

transposeZ :: Parser tok (tok, tok)
transposeZ = Parser go
  where
    go sk fk (l:ls) (r:rs) = sk (l,r) fk ls rs
    go _  fk _      _      = fk




satisfy :: (tok -> Bool) -> (tok -> tok -> a) -> Parser tok a 
satisfy test make = Parser go
  where
    go sk fk (l:ls) (r:rs) | test l && test r = sk (make l r) fk ls rs
    go _  fk _      _                         = fk

{-
prefix :: Eq tok => Parser tok [tok]
prefix = many anyToken

prefix1 :: Eq tok => Parser tok [tok]
prefix1 = many1 anyToken

suffix :: Eq tok => Parser tok [tok]
suffix = many anyToken <* eof

suffix1 :: Eq tok => Parser tok [tok]
suffix1 = many1 anyToken <* eof
-}


{-
oneOf           :: Eq tok => [tok] -> Parser tok tok
oneOf cs        = satisfy (`elem` cs) const



noneOf          :: [Char] -> Parser Char
noneOf cs       = satisfy (`notElem` cs)

-}
